home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / residu.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  6.4 KB  |  208 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module residu)
  13.  
  14. (load-macsyma-macros rzmac)
  15.  
  16. (DECLARE-top (*LEXPR $DIFF $SUBSTITUTE $TAYLOR $EXPAND)
  17.      (SPECIAL $BREAKUP $NOPRINCIPAL VARLIST
  18.           LEADCOEF VAR *ROOTS *FAILURES WFLAG NN*
  19.           SN* SD* $TELLRATLIST GENVAR SEMIRAT* DN* ZN)
  20.      (GENPREFIX RES))
  21.  
  22. (SETQ SEMIRAT* NIL) 
  23.  
  24. (DEFUN POLELIST (D REGION REGION1)
  25.        (PROG (ROOTS $BREAKUP R RR SS R1 S POLE WFLAG CF) 
  26.          (SETQ WFLAG T)
  27.          (SETQ LEADCOEF (POLYINX D VAR 'LEADCOEF))
  28.          (SETQ ROOTS (SOLVECASE D))
  29.          (if (eq roots 'failure) (return ()))
  30.    LOOP1     (COND ((NULL ROOTS)
  31.             (COND ((AND SEMIRAT*
  32.                 (> (f+ (length s) (length r))
  33.                    ;(LENGTH (APPEND S R))
  34.                    (f+ (length ss) (length rr))
  35.                    ;(LENGTH (APPEND SS RR))
  36.                    ))
  37.                (RETURN (LIST CF RR SS R1)))
  38.               (T (RETURN (LIST CF R S R1)))))
  39.            (T (SETQ POLE (CADDAR ROOTS))
  40.               (SETQ D (CADR ROOTS))
  41.               (COND (LEADCOEF
  42.                  (SETQ CF (CONS POLE
  43.                         (CONS 
  44.                          (m^ (M+ VAR (M* -1 pole))
  45.                          d)
  46.                          CF)))))))
  47.     (COND ((FUNCALL REGION POLE)
  48.            (COND ((EQUAL D 1)
  49.               (SETQ S (CONS POLE S)))
  50.              (T (SETQ R (CONS (LIST POLE D) R)))))
  51.           ((FUNCALL REGION1 POLE)
  52.            (COND ((NOT $NOPRINCIPAL)
  53.               (SETQ R1 (CONS POLE R1)))
  54.              (T (return nil))))
  55.           (SEMIRAT*
  56.            (COND ((EQUAL D 1)
  57.               (SETQ SS (CONS POLE SS)))
  58.              (T (SETQ RR (CONS (LIST POLE D) RR))))))
  59.     (SETQ ROOTS (CDDR ROOTS))
  60.     (GO LOOP1)))
  61.  
  62. (DEFUN SOLVECASE (E)
  63.        (COND ((NOT (AMONG VAR E)) NIL)
  64.          (t (let (*FAILURES *ROOTS) 
  65.              (SOLVE E VAR 1)
  66.              (COND (*FAILURES 'failure)
  67.                ((NULL *ROOTS) ())
  68.                (t *ROOTS))))))
  69.  
  70. (DEFUN RES (N D REGION REGION1)
  71.   (let ((PL (polelist d region region1))
  72.     DP A B C FACTORS LEADCOEF)
  73.     (cond 
  74.      ((null pl) nil)
  75.      (t (SETQ FACTORS (CAR PL))
  76.     (SETQ PL (CDR PL))
  77.     (COND ((OR (CADR PL)
  78.            (CADDR PL)) 
  79.            (SETQ DP (SDIFF D VAR))))
  80.     (COND ((CAR PL)
  81.            (SETQ A (m+l (RESIDUE N (COND (LEADCOEF FACTORS)
  82.                          (T D))
  83.                      (CAR PL)))))
  84.           (t (setq a 0.)))
  85.     (COND ((CADR PL)
  86.            (SETQ B (m+l (mapcar #'(lambda (pole)
  87.                     ($residue (m// N D) var pole))
  88.                     (CADR PL)))))
  89.           (t (setq b 0.)))
  90.     (COND ((CADDR PL)
  91.            (SETQ C (m+l (mapcar #'(lambda (pole)
  92.                     ($residue (m// N D) var pole))
  93.                     (CADDR PL)))))
  94.           (t (setq c ())))
  95.     (list (m+ a b) c)))))
  96.  
  97. (DEFUN RESIDUE (ZN FACTORS PL)
  98.   (COND (LEADCOEF 
  99.      (MAPCAR #'(LAMBDA (J)
  100.              (let (((factor1 factor2) (remfactor factors (car j) zn)))
  101.               (RESM0 factor1 factor2 (car j) (cadr j))))
  102.          PL))
  103.     (T (MAPCAR #'(LAMBDA (J)
  104.             (RESM1 (DIV* ZN FACTORS) (CAR J)))
  105.            PL))))
  106.  
  107. (DEFUN RES1 (ZN ZD PL1)
  108.   (SETQ ZD (DIV* ZN ZD))
  109.   (MAPCAR #'(LAMBDA (J) ($RECTFORM ($EXPAND (SUBIN J ZD)))) PL1))
  110.  
  111. (DEFUN RESPROG0 (F G N N2)
  112.        (PROG (A B C R) 
  113.          (SETQ A (RESPROG F G))
  114.          (SETQ B (CADR A) C (PTIMES (CDDR A) N2) A (CAAR A))
  115.          (SETQ A (PTIMES N A) B (PTIMES N B))
  116.          (SETQ R (PDIVIDE A G))
  117.          (SETQ A (CADR R) R (CAR R))
  118.          (SETQ B (CONS (PPLUS (PTIMES (CAR R) F) (PTIMES (CDR R) B))
  119.                (CDR R)))
  120.          (RETURN (CONS (CONS (CAR A) (PTIMES (CDR A) C))
  121.                (CONS (CAR B) (PTIMES (CDR B) C)))))) 
  122.  
  123.  
  124. (DEFUN RESM0 (E N POLE M)
  125.        (SETQ E (DIV* N E))
  126.        (SETQ E ($DIFF E VAR (SUB1 M)))
  127.        (SETQ E ($RECTFORM ($EXPAND (SUBIN POLE E))))
  128.        (DIV* E (SIMPlify `((MFACTORIAL) ,(SUB1 M)))))
  129.  
  130. (DEFUN REMFACTOR (L P N)
  131.        (PROG (F G) 
  132.     LOOP (COND ((NULL L)
  133.             (RETURN (LIST (M*L (CONS LEADCOEF G)) N)))
  134.            ((EQUAL P (CAR L)) (SETQ F (CADR L)))
  135.            (T (SETQ G (CONS (CADR L) G))))
  136.          (SETQ L (CDDR L))
  137.          (GO LOOP)))
  138.  
  139. (DEFUN RESPROG (P1B P2B)
  140.        (PROG (TEMP COEF1R COEF2R FAC COEF1S COEF2S ZEROPOLB F1 F2) 
  141.          (SETQ COEF2R (SETQ COEF1S 0))
  142.          (SETQ COEF2S (SETQ COEF1R 1))
  143.     B1   (COND ((NOT (LESSP (PDEGREE P1B VAR) (PDEGREE P2B VAR))) (GO B2)))
  144.          (SETQ TEMP P2B)
  145.          (SETQ P2B P1B)
  146.          (SETQ P1B TEMP)
  147.          (SETQ TEMP COEF2R)
  148.          (SETQ COEF2R COEF1R)
  149.          (SETQ COEF1R TEMP)
  150.          (SETQ TEMP COEF2S)
  151.          (SETQ COEF2S COEF1S)
  152.          (SETQ COEF1S TEMP)
  153.     B2   (COND ((ZEROP (PDEGREE P2B VAR))
  154.             (RETURN (CONS (CONS COEF2R P2B) (CONS COEF2S P2B)))))
  155.          (SETQ ZEROPOLB (PSIMP VAR
  156.                    (LIST (DIFFERENCE (PDEGREE P1B VAR)
  157.                              (PDEGREE P2B VAR))
  158.                      1)))
  159.          (SETQ FAC (PGCD (CADDR P1B) (CADDR P2B)))
  160.          (SETQ F1 (PQUOTIENT (CADDR P1B) FAC))
  161.          (SETQ F2 (PQUOTIENT (CADDR P2B) FAC))
  162.          (SETQ P1B (PDIFFERENCE (PTIMES F2 (PSIMP (CAR P1B) (CDDDR P1B)))
  163.                     (PTIMES F1
  164.                         (PTIMES ZEROPOLB
  165.                             (PSIMP (CAR P2B)
  166.                                (CDDDR P2B))))))
  167.          (SETQ COEF1R (PDIFFERENCE (PTIMES F2 COEF1R)
  168.                        (PTIMES (PTIMES F1 COEF2R) ZEROPOLB)))
  169.          (SETQ COEF1S (PDIFFERENCE (PTIMES F2 COEF1S)
  170.                        (PTIMES (PTIMES F1 COEF2S) ZEROPOLB)))
  171.          (GO B1))) 
  172.  
  173. ;;;Looks for polynomials. puts polys^(pos-num) in sn* polys^(neg-num) in sd*.
  174. (DEFUN SNUMDEN (E)
  175.   (COND ((OR (ATOM E) 
  176.          (MNUMP E))
  177.      (SETQ SN* (CONS E SN*)))
  178.     ((AND (mexptp E) 
  179.           (INTEGERP (CADDR E)))
  180.      (COND ((POLYINX (CADR E) VAR NIL)
  181.         (COND ((MINUSP (CADDR E))
  182.                (SETQ SD* (CONS (COND ((EQUAL (CADDR E) -1) (CADR E))
  183.                          (T (m^ (CADR E)
  184.                                (MINUS (CADDR E)))))
  185.                        SD*)))
  186.               (T (SETQ SN* (CONS E SN*)))))))
  187.     ((POLYINX E VAR NIL)
  188.      (SETQ SN* (CONS E SN*)))))
  189.  
  190. (SETQ SN* NIL SD* NIL) 
  191.  
  192. (DEFMFUN $RESIDUE (E VAR P)
  193.   (COND (($UNKNOWN E) ($NOUNIFY '$RESIDUE) (LIST '(%RESIDUE) E VAR P))
  194.     (T (LET (SN* SD*)
  195.         (IF (AND (MTIMESP E) (ANDMAPCAR #'SNUMDEN (CDR E)))
  196.             (SETQ NN* (M*L SN*) DN* (M*L SD*))
  197.             (NUMDEN E)))
  198.        (RESM1 (DIV* NN* DN*) P))))
  199.  
  200. (DEFUN RESM1 (E POLE)
  201.   (SETQ POLE ($RECTFORM POLE))
  202.   (SETQ E (RATDISREP ($TAYLOR E VAR POLE
  203.                   0  ;; things like residue(s/(s^2-a^2),s,a) fails if use -1
  204.                   ;;-1
  205.                   )))
  206.   (COEFF E (M^ (M+ (M* -1 POLE) VAR) -1) 1))
  207.  
  208.